perm filename MOVER.F4[Y,MUS] blob sn#067313 filedate 1973-12-01 generic text, type T, neo UTF8
00010	C****  SUBR. MOVER     FUNC. RTLINE
00100		SUBROUTINE MOVER
00200		IMPLICIT INTEGER(A-Q,S-Z)
00300		DIMENSION R(2,40),IR(2,40)
00400		REAL PWDS,POS
00500		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(8),RSTJC
00600		COMMON/ALF/INP(72),ML/XRN/RN(4000)
00700		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00800		COMMON/POSI/STFF(8),JJB,POS/PTR/PWDS(250),ITEM,L,I,IX
00900	      EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
01000		1,(RJC,RJQ(1)),(RJH,RJQ(6)),(RJI,RJQ(7)),(RJK,RJQ(9))
01100		1,(IR,R,RN(3921))
01200		DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/
01300	
01400		JJB=-1
01500	CC	ROV=1000
01600		JB=0
01700	C  99=BACKUP
01900	6	CALL VLINE(RJC,RJD,RJE,RJF)
02000		IF(RJC.EQ.99)RETURN
02100		IF(INP(1).NE.'J')GO TO 12
02300		RRT=RJE
02400		RZRO=RJD
02500		IF(RRT.EQ.0)RRT=200
02900		IF(RZRO.EQ.0)RZRO=.001
03000		RCNT=0
03200		RJSZ=5.0
03300		ASK=-1
03500		RJG=RJC
03600		RJF=0
03700		RJK=0
03800	19	ROV=RRT
03900		RJSZ=RJSZ-.1
04000		RCNT=RCNT+1
04100	C  TEMPORARY COUNTER
04200		ML=1
04300		TYPE F78F,RCNT
04400	
04500		DO 11 KN=-3,4
04600		RSPC=0
04700		RJH=KN
04800		N=0
04900		DO 2 K=1,ITEM
05000		L=PWDS(K)
05100		IF(RTLINE(L))GO TO 2
05200		RA=RN(L+1)
05300		RB=RN(L+2)
05400		IF((RN(L+3).NE.RJH.AND.RA.NE.4).OR.RB.LT.RZRO)GO TO 2
05500		IF(RA.NE.1)GO TO 27
05600		IF(ABS(RN(L+6)).GE.2)GO TO 2
05700	C  SKIPS HOMED NOTES (IN CHORDS)
05800		GO TO 10
05900	27	IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
06000		IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
06100	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
06200	10	N=N+1
06300		R(1,N)=RB
06400		IR(2,N)=L
06500		IF(N.EQ.40)GO TO 28
06600	C  ONLY TREATS 40 ITEMS AT A TIME.
06700	2	CONTINUE
06800		IF(N.EQ.0)GO TO 11
06900	28	DO 23 K=1,N
07000	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
07100	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
07200		GO TO 11
07300	24	RSTJC=RSTFAC(KN+4)
07400	CC	N=N-1
07500		CALL SORT2(R,N)
07600	
07700	CC	IF(RN(IR(2,N)+1).EQ.4)GO TO 22
07800	C  JUMP IF LAST IS A BAR LINE.
07900	CC	N=N+1
08000	CC	R(1,N)=ROV
08100	CC	R(2,N)=3
08200	22	DO 3 K=1,N
08300		L=IR(2,K)
08400		RA=RN(L+1)
08500		RB=0
08600		RX=RN(L+5)
08610		RY=1
08620		RW=AMOD(RN(L+4),100.)
08700		IF(RA.GT.1)GO TO 4
08710		RZ=RN(L+7)
08800		IF((AMOD(RZ,10.).NE.0.AND.RX.LT.20).OR.RZ.GE.10)RB=1.5
08900	C  SPACE FOR DOT OR TAIL(IF STEM UP)
08920		IF(RW.GT.11.OR.RW.LT.2)RB=1.5
08947	C  SPACE FOR LEDGER LINES
08975		IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
09000		IF(AMOD(RX,10.).EQ.0)GO TO 17
09100		RD=2*RY
09200	25	R(2,K-1)=RC+RD*RSTJC
09300		GO TO 17
09400	4	IF(RA.NE.3)GO TO 29
09500		RB=3
09600		IF(RX.GT.100)RB=.8
09800	C  CHECK ON SIZE NEEDED FOR CLEFS
09900	29	IF(RA.NE.4)GO TO 26
10000		RB=-RJSZ/2
10100		RD=.9
10200		GO TO 25
10210	26	IF(RA.NE.18)GO TO 30
10220		IF(RW.GT.9.OR.RX.GT.9)GO TO 31
10230		RB=-1
10240		RD=1
10250		GO TO 25
10260	31	RB=2
10270		RD=3
10280		GO TO 25
10400	30	IF(RA.EQ.7)RB=2*(ABS(RW)-1)
10500	C  SPACES FOR CORRECT NUM OF ACCIS.
10700	C  CHECKS FOR 2-DIGIT METERS
10800	17	RC=(RB+RJSZ)*RSTJC
10810	C  RJSZ=DEFAULT SIZE
10900	3	R(2,K)=RC
11000		RA=R(1,1)
11100		RB=R(2,1)
11200	
11300		DO 13 KX=2,N
11400		RC=R(1,KX)
11500		IF(RC.EQ.RA)GO TO 16
11600	C  SKIPS DOUBLE STOPS
11700	CC	IF(RB)RB=2*RSTJC-RB
11800	14	RD=RA+RB-RC
11900		IF(RD.LE.0)GO TO 16
12000	C  THERE'S ENOUGH ROOM
12100	CC	RD=RA+RB-RC+RD
12200		RJD=RC+RSPC-.001
12300		RJE=1000
12400		RJH=RD
12500		RJI=0
12600		RSPC=RSPC+RD
12700	C  RSPC SAVES TOTAL SPACE ADDED
12800	C  GO EXPAND IT
12900		IF(R(2,KX).NE.0)GO TO 166
13000	16	RB=R(2,KX)
13100	13	RA=RC
13200	11	CONTINUE
13300		IF(ROV.LE.RRT+.01)GO TO 18
13400		RJD=RZRO
13500		RJE=ROV
13600		RJH=RZRO
13700		RJI=RRT-.001
13800	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
13900		ML=3
14000		IF(RJSZ.GT.4)RJSZ=4
14100		GO TO 66
14200	18	ML=4
14400		RJH=ROV
14500		RJI=RRT+2
14510	C  GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
14600		RJD=ROV
14700		RJE=500
14800	166	JJB=-1
14900		JB=0
15000		GO TO 66
15100	12	TYPE 5
15200		ML=2
15300		ACCEPT F78F,RJG,RJH,RJI,RJK
15400		REREAD FA1,L
15500	C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
15600		IF(RJG.EQ.99)GO TO 6
15700		IF(L.NE.'L')GO TO 66
15800		DO 67 K=1,2
15900		RJH=RY
16000		CALL LPEN(RJG,RY,RX)
16100	67	IF(RJG.EQ.99)GO TO 6
16200		RJI=RY
16300	66	JY=1
16400		L=JY
16500		IF(INP(1).EQ.'C')L=I
16600	C  C=COPY
16700		RDIS=0
16800		IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
16900	
17000	6551	RB=RN(JY)
17100		JB=JB+1
17200		IF(RTLINE(JY))GO TO 7551
17300	C  IF STAFF#>4, ALL STAVES ARE MOVED.
17400		RA=RN(JY+1)
17500		IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
17600	C SKIPS IF NOT SPECIAL CODE NUM.
17700		RN2=RN(JY+2)
17800		IF(RN2.GT.RJE)GO TO 7551
17900		RC=-1
18000		RD=0
18100		IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
18200		IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
18300	C RC=0 FOR CODES 4,8,9
18400		RN6=RN(JY+6)
18500		IF(RN2.GE.RJD)GO TO 8
18600	      IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
18700	C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
18800	C  IF INP(1)='C' MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
18900	8	IF(ASK)GO TO 100
19000		CALL ASKIT
19100		IF(K.EQ.'N')GO TO 7551
19200		IF(K.EQ.'X')GO TO 1
19300	C  'X'=EXIT
19400	C  N=NO, <CR>=YES
19500	100	IF(INP(1).NE.'C')GO TO 9551
19600		K=RB+2
19700		CALL LOOP(0,K,1,L,JY,RN)
19800		ITEM=ITEM+1
19900		IF(JJB)JJB=ITEM
20000	C  JJB SAVES ITEM # FOR MAIN PROG.
20100		PWDS(ITEM+1)=L+K+1
20200	9551	IF(JJB)JJB=JB
20300	C   (50=CRESC., DECRESC.)
20400		IF(RJC.LT.5)RN(L+3)=RJG
20500	C   RJG IS NEW STAFF NUM.
20600		RQ6=RN6-RJE
20700		RX=0
20800		IF(RA.NE.9.OR.RB.LT.7)GO TO 21
20900		RX=RN(L+9)
21000		RY=RX-RJE
21100		RZ=RJD-RX
21200		IF(RY.AND.RZ)RX=-1
21300	C PARTIAL BEAM IS WITHIN MOVE AREA.
21400	21	IF(RJI.EQ.0)GO TO 2551
21500		IF(RN2.GE.RJD)RN(L+2)=RJH+(RN2-RJD)*RDIS
21600		IF(RC)GO TO 7552
21700		IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
21800		IF(RQ6)RN(L+6)=RJH+(RN(JY+6)-RJD)*RDIS 
21900	C  END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
22000		IF(RA.NE.9)GO TO 7552
22100		IF(RX)RN(L+9)=RJH+(RN(JY+9)-RJD)*RDIS
22200	C  ONLY TRUE WHEN RA=9
22300		GO TO 7552
22400	
22500	2551	IF(RN2.GE.RJD)RN2=RN2+RJH
22600		RN(L+2)=RN2
22700	      IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
22800		IF(RX)RN(L+9)=RN(JY+9)+RJH
22900		IF(RN2.GT.ROV)ROV=RN2
23000	C  NOT YET FIXED FOR ENDS OF SLURS OR LINES
23100	7552	L=RB+3+L
23200		IF(RJK.EQ.0)GO TO 7551
23300	1551	IF((RB.LT.3..AND.RA.NE.6.).OR.RA.EQ.18)GO TO 7551
23400	C  'U-D' SKIPS METER, STAFF, ETC.
23500		JX=JY
23600		IF(INP(1).EQ.'C')JX=PWDS(ITEM)
23700		RN(JX+4)=RN(JX+4)+RJK
23800		IF(RC.EQ.0)RN(JX+5)=RN(JX+5)+RJK
23900	7551	JY=RB+3+JY
24000		IF(INP(1).NE.'C')L=JY
24100		IF(JY.LT.I)GO TO 6551
24200		GO TO (16,1,19,101),ML
24300	101	JJB=1
24400	1	CALL HYDPOG(3)
24500	5	FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN #'/)
24600		END
24700	
24900		FUNCTION RTLINE(L)
25000		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
25050		RTLINE=-1
25100		IF(RJQ(1).GT.4.OR.RN(L+3).EQ.RJQ(1))RTLINE=0
25200		END